home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / share / multimed / myflix_win32 / myflix_win32.exe / data1.cab / Libraries / tk8.0 / Tkfbox.tcl < prev    next >
Text File  |  1998-03-10  |  37KB  |  1,431 lines
  1. # tkfbox.tcl --
  2. #
  3. #    Implements the "TK" standard file selection dialog box. This
  4. #    dialog box is used on the Unix platforms whenever the tk_strictMotif
  5. #    flag is not set.
  6. #
  7. #    The "TK" standard file selection dialog box is similar to the
  8. #    file selection dialog box on Win95(TM). The user can navigate
  9. #    the directories by clicking on the folder icons or by
  10. #    selectinf the "Directory" option menu. The user can select
  11. #    files by clicking on the file icons or by entering a filename
  12. #    in the "Filename:" entry.
  13. #
  14. # SCCS: @(#) tkfbox.tcl 1.12 97/07/22 15:19:55
  15. #
  16. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  17. #
  18. # See the file "license.terms" for information on usage and redistribution
  19. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20. #
  21.  
  22. #----------------------------------------------------------------------
  23. #
  24. #              I C O N   L I S T
  25. #
  26. # This is a pseudo-widget that implements the icon list inside the 
  27. # tkFDialog dialog box.
  28. #
  29. #----------------------------------------------------------------------
  30.  
  31. # tkIconList --
  32. #
  33. #    Creates an IconList widget.
  34. #
  35. proc tkIconList {w args} {
  36.     upvar #0 $w data
  37.  
  38.     tkIconList_Config $w $args
  39.     tkIconList_Create $w
  40. }
  41.  
  42. # tkIconList_Config --
  43. #
  44. #    Configure the widget variables of IconList, according to the command
  45. #    line arguments.
  46. #
  47. proc tkIconList_Config {w argList} {
  48.     upvar #0 $w data
  49.  
  50.     # 1: the configuration specs
  51.     #
  52.     set specs {
  53.     {-browsecmd "" "" ""}
  54.     {-command "" "" ""}
  55.     }
  56.  
  57.     # 2: parse the arguments
  58.     #
  59.     tclParseConfigSpec $w $specs "" $argList
  60. }
  61.  
  62. # tkIconList_Create --
  63. #
  64. #    Creates an IconList widget by assembling a canvas widget and a
  65. #    scrollbar widget. Sets all the bindings necessary for the IconList's
  66. #    operations.
  67. #
  68. proc tkIconList_Create {w} {
  69.     upvar #0 $w data
  70.  
  71.     frame $w
  72.     set data(sbar)   [scrollbar $w.sbar -orient horizontal \
  73.     -highlightthickness 0 -takefocus 0]
  74.     set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \
  75.     -width 400 -height 120 -takefocus 1]
  76.     pack $data(sbar) -side bottom -fill x -padx 2
  77.     pack $data(canvas) -expand yes -fill both
  78.  
  79.     $data(sbar) config -command "$data(canvas) xview"
  80.     $data(canvas) config -xscrollcommand "$data(sbar) set"
  81.  
  82.     # Initializes the max icon/text width and height and other variables
  83.     #
  84.     set data(maxIW) 1
  85.     set data(maxIH) 1
  86.     set data(maxTW) 1
  87.     set data(maxTH) 1
  88.     set data(numItems) 0
  89.     set data(curItem)  {}
  90.     set data(noScroll) 1
  91.  
  92.     # Creates the event bindings.
  93.     #
  94.     bind $data(canvas) <Configure> "tkIconList_Arrange $w"
  95.  
  96.     bind $data(canvas) <1>         "tkIconList_Btn1 $w %x %y"
  97.     bind $data(canvas) <B1-Motion> "tkIconList_Motion1 $w %x %y"
  98.     bind $data(canvas) <Double-1>  "tkIconList_Double1 $w %x %y"
  99.     bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat"
  100.     bind $data(canvas) <B1-Leave>  "tkIconList_Leave1 $w %x %y"
  101.     bind $data(canvas) <B1-Enter>  "tkCancelRepeat"
  102.  
  103.     bind $data(canvas) <Up>        "tkIconList_UpDown $w -1"
  104.     bind $data(canvas) <Down>      "tkIconList_UpDown $w  1"
  105.     bind $data(canvas) <Left>      "tkIconList_LeftRight $w -1"
  106.     bind $data(canvas) <Right>     "tkIconList_LeftRight $w  1"
  107.     bind $data(canvas) <Return>    "tkIconList_ReturnKey $w"
  108.     bind $data(canvas) <KeyPress>  "tkIconList_KeyPress $w %A"
  109.     bind $data(canvas) <Control-KeyPress> ";"
  110.     bind $data(canvas) <Alt-KeyPress>  ";"
  111.  
  112.     bind $data(canvas) <FocusIn>   "tkIconList_FocusIn $w"
  113.  
  114.     return $w
  115. }
  116.  
  117. # tkIconList_AutoScan --
  118. #
  119. # This procedure is invoked when the mouse leaves an entry window
  120. # with button 1 down.  It scrolls the window up, down, left, or
  121. # right, depending on where the mouse left the window, and reschedules
  122. # itself as an "after" command so that the window continues to scroll until
  123. # the mouse moves back into the window or the mouse button is released.
  124. #
  125. # Arguments:
  126. # w -        The IconList window.
  127. #
  128. proc tkIconList_AutoScan {w} {
  129.     upvar #0 $w data
  130.     global tkPriv
  131.  
  132.     if {![winfo exists $w]} return
  133.     set x $tkPriv(x)
  134.     set y $tkPriv(y)
  135.  
  136.     if $data(noScroll) {
  137.     return
  138.     }
  139.     if {$x >= [winfo width $data(canvas)]} {
  140.     $data(canvas) xview scroll 1 units
  141.     } elseif {$x < 0} {
  142.     $data(canvas) xview scroll -1 units
  143.     } elseif {$y >= [winfo height $data(canvas)]} {
  144.     # do nothing
  145.     } elseif {$y < 0} {
  146.     # do nothing
  147.     } else {
  148.     return
  149.     }
  150.  
  151.     tkIconList_Motion1 $w $x $y
  152.     set tkPriv(afterId) [after 50 tkIconList_AutoScan $w]
  153. }
  154.  
  155. # Deletes all the items inside the canvas subwidget and reset the IconList's
  156. # state.
  157. #
  158. proc tkIconList_DeleteAll {w} {
  159.     upvar #0 $w data
  160.     upvar #0 $w:itemList itemList
  161.  
  162.     $data(canvas) delete all
  163.     catch {unset data(selected)}
  164.     catch {unset data(rect)}
  165.     catch {unset data(list)}
  166.     catch {unset itemList}
  167.     set data(maxIW) 1
  168.     set data(maxIH) 1
  169.     set data(maxTW) 1
  170.     set data(maxTH) 1
  171.     set data(numItems) 0
  172.     set data(curItem)  {}
  173.     set data(noScroll) 1
  174.     $data(sbar) set 0.0 1.0
  175.     $data(canvas) xview moveto 0
  176. }
  177.  
  178. # Adds an icon into the IconList with the designated image and text
  179. #
  180. proc tkIconList_Add {w image text} {
  181.     upvar #0 $w data
  182.     upvar #0 $w:itemList itemList
  183.     upvar #0 $w:textList textList
  184.  
  185.     set iTag [$data(canvas) create image 0 0 -image $image -anchor nw]
  186.     set tTag [$data(canvas) create text  0 0 -text  $text  -anchor nw \
  187.     -font $data(font)]
  188.     set rTag [$data(canvas) create rect  0 0 0 0 -fill "" -outline ""]
  189.     
  190.     set b [$data(canvas) bbox $iTag]
  191.     set iW [expr [lindex $b 2]-[lindex $b 0]]
  192.     set iH [expr [lindex $b 3]-[lindex $b 1]]
  193.     if {$data(maxIW) < $iW} {
  194.     set data(maxIW) $iW
  195.     }
  196.     if {$data(maxIH) < $iH} {
  197.     set data(maxIH) $iH
  198.     }
  199.     
  200.     set b [$data(canvas) bbox $tTag]
  201.     set tW [expr [lindex $b 2]-[lindex $b 0]]
  202.     set tH [expr [lindex $b 3]-[lindex $b 1]]
  203.     if {$data(maxTW) < $tW} {
  204.     set data(maxTW) $tW
  205.     }
  206.     if {$data(maxTH) < $tH} {
  207.     set data(maxTH) $tH
  208.     }
  209.     
  210.     lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW $tH $data(numItems)]
  211.     set itemList($rTag) [list $iTag $tTag $text $data(numItems)]
  212.     set textList($data(numItems)) [string tolower $text]
  213.     incr data(numItems)
  214. }
  215.  
  216. # Places the icons in a column-major arrangement.
  217. #
  218. proc tkIconList_Arrange {w} {
  219.     upvar #0 $w data
  220.  
  221.     if ![info exists data(list)] {
  222.     if {[info exists data(canvas)] && [winfo exists $data(canvas)]} {
  223.         set data(noScroll) 1
  224.         $data(sbar) config -command ""
  225.     }
  226.     return
  227.     }
  228.  
  229.     set W [winfo width  $data(canvas)]
  230.     set H [winfo height $data(canvas)]
  231.     set pad [expr [$data(canvas) cget -highlightthickness] + \
  232.     [$data(canvas) cget -bd]]
  233.     if {$pad < 2} {
  234.     set pad 2
  235.     }
  236.  
  237.     incr W -[expr $pad*2]
  238.     incr H -[expr $pad*2]
  239.  
  240.     set dx [expr $data(maxIW) + $data(maxTW) + 8]
  241.     if {$data(maxTH) > $data(maxIH)} {
  242.     set dy $data(maxTH)
  243.     } else {
  244.     set dy $data(maxIH)
  245.     }
  246.     incr dy 2
  247.     set shift [expr $data(maxIW) + 4]
  248.  
  249.     set x [expr $pad * 2]
  250.     set y [expr $pad * 1]
  251.     set usedColumn 0
  252.     foreach sublist $data(list) {
  253.     set usedColumn 1
  254.     set iTag [lindex $sublist 0]
  255.     set tTag [lindex $sublist 1]
  256.     set rTag [lindex $sublist 2]
  257.     set iW   [lindex $sublist 3]
  258.     set iH   [lindex $sublist 4]
  259.     set tW   [lindex $sublist 5]
  260.     set tH   [lindex $sublist 6]
  261.  
  262.     set i_dy [expr ($dy - $iH)/2]
  263.     set t_dy [expr ($dy - $tH)/2]
  264.  
  265.     $data(canvas) coords $iTag $x                 [expr $y + $i_dy]
  266.     $data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy]
  267.     $data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy]
  268.     $data(canvas) coords $rTag $x $y [expr $x+$dx] [expr $y+$dy]
  269.  
  270.     incr y $dy
  271.     if {[expr $y + $dy] > $H} {
  272.         set y [expr $pad * 1]
  273.         incr x $dx
  274.         set usedColumn 0
  275.     }
  276.     }
  277.  
  278.     if {$usedColumn} {
  279.     set sW [expr $x + $dx]
  280.     } else {
  281.     set sW $x
  282.     }
  283.  
  284.     if {$sW < $W} {
  285.     $data(canvas) config -scrollregion "$pad $pad $sW $H"
  286.     $data(sbar) config -command ""
  287.     $data(canvas) xview moveto 0
  288.     set data(noScroll) 1
  289.     } else {
  290.     $data(canvas) config -scrollregion "$pad $pad $sW $H"
  291.     $data(sbar) config -command "$data(canvas) xview"
  292.     set data(noScroll) 0
  293.     }
  294.  
  295.     set data(itemsPerColumn) [expr ($H-$pad)/$dy]
  296.     if {$data(itemsPerColumn) < 1} {
  297.     set data(itemsPerColumn) 1
  298.     }
  299.  
  300.     if {$data(curItem) != {}} {
  301.     tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0
  302.     }
  303. }
  304.  
  305. # Gets called when the user invokes the IconList (usually by double-clicking
  306. # or pressing the Return key).
  307. #
  308. proc tkIconList_Invoke {w} {
  309.     upvar #0 $w data
  310.  
  311.     if {[string compare $data(-command) ""] && [info exists data(selected)]} {
  312.     eval $data(-command) [list $data(selected)]
  313.     }
  314. }
  315.  
  316. # tkIconList_See --
  317. #
  318. #    If the item is not (completely) visible, scroll the canvas so that
  319. #    it becomes visible.
  320. proc tkIconList_See {w rTag} {
  321.     upvar #0 $w data
  322.     upvar #0 $w:itemList itemList
  323.  
  324.     if $data(noScroll) {
  325.     return
  326.     }
  327.     set sRegion [$data(canvas) cget -scrollregion]
  328.     if ![string compare $sRegion {}] {
  329.     return
  330.     }
  331.  
  332.     if ![info exists itemList($rTag)] {
  333.     return
  334.     }
  335.  
  336.  
  337.     set bbox [$data(canvas) bbox $rTag]
  338.     set pad [expr [$data(canvas) cget -highlightthickness] + \
  339.     [$data(canvas) cget -bd]]
  340.  
  341.     set x1 [lindex $bbox 0]
  342.     set x2 [lindex $bbox 2]
  343.     incr x1 -[expr $pad * 2]
  344.     incr x2 -[expr $pad * 1]
  345.  
  346.     set cW [expr [winfo width $data(canvas)] - $pad*2]
  347.  
  348.     set scrollW [expr [lindex $sRegion 2]-[lindex $sRegion 0]+1]
  349.     set dispX [expr int([lindex [$data(canvas) xview] 0]*$scrollW)]
  350.     set oldDispX $dispX
  351.  
  352.     # check if out of the right edge
  353.     #
  354.     if {[expr $x2 - $dispX] >= $cW} {
  355.     set dispX [expr $x2 - $cW]
  356.     }
  357.     # check if out of the left edge
  358.     #
  359.     if {[expr $x1 - $dispX] < 0} {
  360.     set dispX $x1
  361.     }
  362.  
  363.     if {$oldDispX != $dispX} {
  364.     set fraction [expr double($dispX)/double($scrollW)]
  365.     $data(canvas) xview moveto $fraction
  366.     }
  367. }
  368.  
  369. proc tkIconList_SelectAtXY {w x y} {
  370.     upvar #0 $w data
  371.  
  372.     tkIconList_Select $w [$data(canvas) find closest \
  373.     [$data(canvas) canvasx $x] [$data(canvas) canvasy $y]]
  374. }
  375.  
  376. proc tkIconList_Select {w rTag {callBrowse 1}} {
  377.     upvar #0 $w data
  378.     upvar #0 $w:itemList itemList
  379.  
  380.     if ![info exists itemList($rTag)] {
  381.     return
  382.     }
  383.     set iTag   [lindex $itemList($rTag) 0]
  384.     set tTag   [lindex $itemList($rTag) 1]
  385.     set text   [lindex $itemList($rTag) 2]
  386.     set serial [lindex $itemList($rTag) 3]
  387.  
  388.     if ![info exists data(rect)] {
  389.         set data(rect) [$data(canvas) create rect 0 0 0 0 \
  390.         -fill #a0a0ff -outline #a0a0ff]
  391.     }
  392.     $data(canvas) lower $data(rect)
  393.     set bbox [$data(canvas) bbox $tTag]
  394.     eval $data(canvas) coords $data(rect) $bbox
  395.  
  396.     set data(curItem) $serial
  397.     set data(selected) $text
  398.     
  399.     if {$callBrowse} {
  400.     if [string compare $data(-browsecmd) ""] {
  401.         eval $data(-browsecmd) [list $text]
  402.     }
  403.     }
  404. }
  405.  
  406. proc tkIconList_Unselect {w} {
  407.     upvar #0 $w data
  408.  
  409.     if [info exists data(rect)] {
  410.     $data(canvas) delete $data(rect)
  411.     unset data(rect)
  412.     }
  413.     if [info exists data(selected)] {
  414.     unset data(selected)
  415.     }
  416.     set data(curItem)  {}
  417. }
  418.  
  419. # Returns the selected item
  420. #
  421. proc tkIconList_Get {w} {
  422.     upvar #0 $w data
  423.  
  424.     if [info exists data(selected)] {
  425.     return $data(selected)
  426.     } else {
  427.     return ""
  428.     }
  429. }
  430.  
  431.  
  432. proc tkIconList_Btn1 {w x y} {
  433.     upvar #0 $w data
  434.  
  435.     focus $data(canvas)
  436.     tkIconList_SelectAtXY $w $x $y
  437. }
  438.  
  439. # Gets called on button-1 motions
  440. #
  441. proc tkIconList_Motion1 {w x y} {
  442.     global tkPriv
  443.     set tkPriv(x) $x
  444.     set tkPriv(y) $y
  445.  
  446.     tkIconList_SelectAtXY $w $x $y
  447. }
  448.  
  449. proc tkIconList_Double1 {w x y} {
  450.     upvar #0 $w data
  451.  
  452.     if {$data(curItem) != {}} {
  453.     tkIconList_Invoke $w
  454.     }
  455. }
  456.  
  457. proc tkIconList_ReturnKey {w} {
  458.     tkIconList_Invoke $w
  459. }
  460.  
  461. proc tkIconList_Leave1 {w x y} {
  462.     global tkPriv
  463.  
  464.     set tkPriv(x) $x
  465.     set tkPriv(y) $y
  466.     tkIconList_AutoScan $w
  467. }
  468.  
  469. proc tkIconList_FocusIn {w} {
  470.     upvar #0 $w data
  471.  
  472.     if ![info exists data(list)] {
  473.     return
  474.     }
  475.  
  476.     if {$data(curItem) == {}} {
  477.     set rTag [lindex [lindex $data(list) 0] 2]
  478.     tkIconList_Select $w $rTag
  479.     }
  480. }
  481.  
  482. # tkIconList_UpDown --
  483. #
  484. # Moves the active element up or down by one element
  485. #
  486. # Arguments:
  487. # w -        The IconList widget.
  488. # amount -    +1 to move down one item, -1 to move back one item.
  489. #
  490. proc tkIconList_UpDown {w amount} {
  491.     upvar #0 $w data
  492.  
  493.     if ![info exists data(list)] {
  494.     return
  495.     }
  496.  
  497.     if {$data(curItem) == {}} {
  498.     set rTag [lindex [lindex $data(list) 0] 2]
  499.     } else {
  500.     set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
  501.     set rTag [lindex [lindex $data(list) [expr $data(curItem)+$amount]] 2]
  502.     if ![string compare $rTag ""] {
  503.         set rTag $oldRTag
  504.     }
  505.     }
  506.  
  507.     if [string compare $rTag ""] {
  508.     tkIconList_Select $w $rTag
  509.     tkIconList_See $w $rTag
  510.     }
  511. }
  512.  
  513. # tkIconList_LeftRight --
  514. #
  515. # Moves the active element left or right by one column
  516. #
  517. # Arguments:
  518. # w -        The IconList widget.
  519. # amount -    +1 to move right one column, -1 to move left one column.
  520. #
  521. proc tkIconList_LeftRight {w amount} {
  522.     upvar #0 $w data
  523.  
  524.     if ![info exists data(list)] {
  525.     return
  526.     }
  527.     if {$data(curItem) == {}} {
  528.     set rTag [lindex [lindex $data(list) 0] 2]
  529.     } else {
  530.     set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
  531.     set newItem [expr $data(curItem)+($amount*$data(itemsPerColumn))]
  532.     set rTag [lindex [lindex $data(list) $newItem] 2]
  533.     if ![string compare $rTag ""] {
  534.         set rTag $oldRTag
  535.     }
  536.     }
  537.  
  538.     if [string compare $rTag ""] {
  539.     tkIconList_Select $w $rTag
  540.     tkIconList_See $w $rTag
  541.     }
  542. }
  543.  
  544. #----------------------------------------------------------------------
  545. #        Accelerator key bindings
  546. #----------------------------------------------------------------------
  547.  
  548. # tkIconList_KeyPress --
  549. #
  550. #    Gets called when user enters an arbitrary key in the listbox.
  551. #
  552. proc tkIconList_KeyPress {w key} {
  553.     global tkPriv
  554.  
  555.     append tkPriv(ILAccel,$w) $key
  556.     tkIconList_Goto $w $tkPriv(ILAccel,$w)
  557.     catch {
  558.     after cancel $tkPriv(ILAccel,$w,afterId)
  559.     }
  560.     set tkPriv(ILAccel,$w,afterId) [after 500 tkIconList_Reset $w]
  561. }
  562.  
  563. proc tkIconList_Goto {w text} {
  564.     upvar #0 $w data
  565.     upvar #0 $w:textList textList
  566.     global tkPriv
  567.     
  568.     if ![info exists data(list)] {
  569.     return
  570.     }
  571.  
  572.     if {[string length $text] == 0} {
  573.     return
  574.     }
  575.  
  576.     if {$data(curItem) == {} || $data(curItem) == 0} {
  577.     set start  0
  578.     } else {
  579.     set start  $data(curItem)
  580.     }
  581.  
  582.     set text [string tolower $text]
  583.     set theIndex -1
  584.     set less 0
  585.     set len [string length $text]
  586.     set len0 [expr $len-1]
  587.     set i $start
  588.  
  589.     # Search forward until we find a filename whose prefix is an exact match
  590.     # with $text
  591.     while 1 {
  592.     set sub [string range $textList($i) 0 $len0]
  593.     if {[string compare $text $sub] == 0} {
  594.         set theIndex $i
  595.         break
  596.     }
  597.     incr i
  598.     if {$i == $data(numItems)} {
  599.         set i 0
  600.     }
  601.     if {$i == $start} {
  602.         break
  603.     }
  604.     }
  605.  
  606.     if {$theIndex > -1} {
  607.     set rTag [lindex [lindex $data(list) $theIndex] 2]
  608.     tkIconList_Select $w $rTag 0
  609.     tkIconList_See $w $rTag
  610.     }
  611. }
  612.  
  613. proc tkIconList_Reset {w} {
  614.     global tkPriv
  615.  
  616.     catch {unset tkPriv(ILAccel,$w)}
  617. }
  618.  
  619. #----------------------------------------------------------------------
  620. #
  621. #              F I L E   D I A L O G
  622. #
  623. #----------------------------------------------------------------------
  624.  
  625. # tkFDialog --
  626. #
  627. #    Implements the TK file selection dialog. This dialog is used when
  628. #    the tk_strictMotif flag is set to false. This procedure shouldn't
  629. #    be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
  630. #
  631. proc tkFDialog {args} {
  632.     global tkPriv
  633.     set w .__tk_filedialog
  634.     upvar #0 $w data
  635.  
  636.     if ![string compare [lindex [info level 0] 0] tk_getOpenFile] {
  637.     set type open
  638.     } else {
  639.     set type save
  640.     }
  641.  
  642.     tkFDialog_Config $w $type $args
  643.  
  644.     # (re)create the dialog box if necessary
  645.     #
  646.     if {![winfo exists $w]} {
  647.     tkFDialog_Create $w
  648.     } elseif {[string compare [winfo class $w] TkFDialog]} {
  649.     destroy $w
  650.     tkFDialog_Create $w
  651.     }
  652.     wm transient $w $data(-parent)
  653.  
  654.     # 5. Initialize the file types menu
  655.     #
  656.     if {$data(-filetypes) != {}} {
  657.     $data(typeMenu) delete 0 end
  658.     foreach type $data(-filetypes) {
  659.         set title  [lindex $type 0]
  660.         set filter [lindex $type 1]
  661.         $data(typeMenu) add command -label $title \
  662.         -command [list tkFDialog_SetFilter $w $type]
  663.     }
  664.     tkFDialog_SetFilter $w [lindex $data(-filetypes) 0]
  665.     $data(typeMenuBtn) config -state normal
  666.     $data(typeMenuLab) config -state normal
  667.     } else {
  668.     set data(filter) "*"
  669.     $data(typeMenuBtn) config -state disabled -takefocus 0
  670.     $data(typeMenuLab) config -state disabled
  671.     }
  672.  
  673.     tkFDialog_UpdateWhenIdle $w
  674.  
  675.     # 6. Withdraw the window, then update all the geometry information
  676.     # so we know how big it wants to be, then center the window in the
  677.     # display and de-iconify it.
  678.  
  679.     wm withdraw $w
  680.     update idletasks
  681.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  682.         - [winfo vrootx [winfo parent $w]]]
  683.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  684.         - [winfo vrooty [winfo parent $w]]]
  685.     wm geom $w [winfo reqwidth $w]x[winfo reqheight $w]+$x+$y
  686.     wm deiconify $w
  687.     wm title $w $data(-title)
  688.  
  689.     # 7. Set a grab and claim the focus too.
  690.  
  691.     set oldFocus [focus]
  692.     set oldGrab [grab current $w]
  693.     if {$oldGrab != ""} {
  694.     set grabStatus [grab status $oldGrab]
  695.     }
  696.     grab $w
  697.     focus $data(ent)
  698.     $data(ent) delete 0 end
  699.     $data(ent) insert 0 $data(selectFile)
  700.     $data(ent) select from 0
  701.     $data(ent) select to   end
  702.     $data(ent) icursor end
  703.  
  704.     # 8. Wait for the user to respond, then restore the focus and
  705.     # return the index of the selected button.  Restore the focus
  706.     # before deleting the window, since otherwise the window manager
  707.     # may take the focus away so we can't redirect it.  Finally,
  708.     # restore any grab that was in effect.
  709.  
  710.     tkwait variable tkPriv(selectFilePath)
  711.     catch {focus $oldFocus}
  712.     grab release $w
  713.     wm withdraw $w
  714.     if {$oldGrab != ""} {
  715.     if {$grabStatus == "global"} {
  716.         grab -global $oldGrab
  717.     } else {
  718.         grab $oldGrab
  719.     }
  720.     }
  721.     return $tkPriv(selectFilePath)
  722. }
  723.  
  724. # tkFDialog_Config --
  725. #
  726. #    Configures the TK filedialog according to the argument list
  727. #
  728. proc tkFDialog_Config {w type argList} {
  729.     upvar #0 $w data
  730.  
  731.     set data(type) $type
  732.  
  733.     # 1: the configuration specs
  734.     #
  735.     set specs {
  736.     {-defaultextension "" "" ""}
  737.     {-filetypes "" "" ""}
  738.     {-initialdir "" "" ""}
  739.     {-initialfile "" "" ""}
  740.     {-parent "" "" "."}
  741.     {-title "" "" ""}
  742.     }
  743.  
  744.     # 2: default values depending on the type of the dialog
  745.     #
  746.     if ![info exists data(selectPath)] {
  747.     # first time the dialog has been popped up
  748.     set data(selectPath) [pwd]
  749.     set data(selectFile) ""
  750.     }
  751.  
  752.     # 3: parse the arguments
  753.     #
  754.     tclParseConfigSpec $w $specs "" $argList
  755.  
  756.     if ![string compare $data(-title) ""] {
  757.     if ![string compare $type "open"] {
  758.         set data(-title) "Open"
  759.     } else {
  760.         set data(-title) "Save As"
  761.     }
  762.     }
  763.  
  764.     # 4: set the default directory and selection according to the -initial
  765.     #    settings
  766.     #
  767.     if [string compare $data(-initialdir) ""] {
  768.     if [file isdirectory $data(-initialdir)] {
  769.         set data(selectPath) [glob $data(-initialdir)]
  770.     } else {
  771.         error "\"$data(-initialdir)\" is not a valid directory"
  772.     }
  773.     }
  774.     set data(selectFile) $data(-initialfile)
  775.  
  776.     # 5. Parse the -filetypes option
  777.     #
  778.     set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]
  779.  
  780.     if ![winfo exists $data(-parent)] {
  781.     error "bad window path name \"$data(-parent)\""
  782.     }
  783. }
  784.  
  785. proc tkFDialog_Create {w} {
  786.     upvar #0 $w data
  787.     global tk_library
  788.  
  789.     toplevel $w -class TkFDialog
  790.  
  791.     # f1: the frame with the directory option menu
  792.     #
  793.     set f1 [frame $w.f1]
  794.     label $f1.lab -text "Directory:" -under 0
  795.     set data(dirMenuBtn) $f1.menu
  796.     set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) $w] ""]
  797.     set data(upBtn) [button $f1.up]
  798.     if ![info exists tkPriv(updirImage)] {
  799.     set tkPriv(updirImage) [image create bitmap -data {
  800. #define updir_width 28
  801. #define updir_height 16
  802. static char updir_bits[] = {
  803.    0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
  804.    0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
  805.    0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
  806.    0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
  807.    0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
  808.    0xf0, 0xff, 0xff, 0x01};}]
  809.     }
  810.     $data(upBtn) config -image $tkPriv(updirImage)
  811.  
  812.     $f1.menu config -takefocus 1 -highlightthickness 2
  813.  
  814.     pack $data(upBtn) -side right -padx 4 -fill both
  815.     pack $f1.lab -side left -padx 4 -fill both
  816.     pack $f1.menu -expand yes -fill both -padx 4
  817.  
  818.     # data(icons): the IconList that list the files and directories.
  819.     #
  820.     set data(icons) [tkIconList $w.icons \
  821.     -browsecmd "tkFDialog_ListBrowse $w" \
  822.     -command   "tkFDialog_ListInvoke $w"]
  823.  
  824.     # f2: the frame with the OK button and the "file name" field
  825.     #
  826.     set f2 [frame $w.f2 -bd 0]
  827.     label $f2.lab -text "File name:" -anchor e -width 14 -under 5 -pady 0
  828.     set data(ent) [entry $f2.ent]
  829.  
  830.     # The font to use for the icons. The default Canvas font on Unix
  831.     # is just deviant.
  832.     global $w.icons
  833.     set $w.icons(font) [$data(ent) cget -font]
  834.  
  835.     # f3: the frame with the cancel button and the file types field
  836.     #
  837.     set f3 [frame $w.f3 -bd 0]
  838.  
  839.     # The "File of types:" label needs to be grayed-out when
  840.     # -filetypes are not specified. The label widget does not support
  841.     # grayed-out text on monochrome displays. Therefore, we have to
  842.     # use a button widget to emulate a label widget (by setting its
  843.     # bindtags)
  844.  
  845.     set data(typeMenuLab) [button $f3.lab -text "Files of type:" \
  846.     -anchor e -width 14 -under 9 \
  847.     -bd [$f2.lab cget -bd] \
  848.     -highlightthickness [$f2.lab cget -highlightthickness] \
  849.     -relief [$f2.lab cget -relief] \
  850.     -padx [$f2.lab cget -padx] \
  851.     -pady [$f2.lab cget -pady]]
  852.     bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \
  853.         [winfo toplevel $data(typeMenuLab)] all]
  854.  
  855.     set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 -menu $f3.menu.m]
  856.     set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
  857.     $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \
  858.     -relief raised -bd 2 -anchor w
  859.  
  860.     # the okBtn is created after the typeMenu so that the keyboard traversal
  861.     # is in the right order
  862.     set data(okBtn)     [button $f2.ok     -text OK     -under 0 -width 6 \
  863.     -default active -pady 3]
  864.     set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\
  865.     -default normal -pady 3]
  866.  
  867.     # pack the widgets in f2 and f3
  868.     #
  869.     pack $data(okBtn) -side right -padx 4 -anchor e
  870.     pack $f2.lab -side left -padx 4
  871.     pack $f2.ent -expand yes -fill x -padx 2 -pady 0
  872.     
  873.     pack $data(cancelBtn) -side right -padx 4 -anchor w
  874.     pack $data(typeMenuLab) -side left -padx 4
  875.     pack $data(typeMenuBtn) -expand yes -fill x -side right
  876.  
  877.     # Pack all the frames together. We are done with widget construction.
  878.     #
  879.     pack $f1 -side top -fill x -pady 4
  880.     pack $f3 -side bottom -fill x
  881.     pack $f2 -side bottom -fill x
  882.     pack $data(icons) -expand yes -fill both -padx 4 -pady 1
  883.  
  884.     # Set up the event handlers
  885.     #
  886.     bind $data(ent) <Return>  "tkFDialog_ActivateEnt $w"
  887.     
  888.     $data(upBtn)     config -command "tkFDialog_UpDirCmd $w"
  889.     $data(okBtn)     config -command "tkFDialog_OkCmd $w"
  890.     $data(cancelBtn) config -command "tkFDialog_CancelCmd $w"
  891.  
  892.     trace variable data(selectPath) w "tkFDialog_SetPath $w"
  893.  
  894.     bind $w <Alt-d> "focus $data(dirMenuBtn)"
  895.     bind $w <Alt-t> [format {
  896.     if {"[%s cget -state]" == "normal"} {
  897.         focus %s
  898.     }
  899.     } $data(typeMenuBtn) $data(typeMenuBtn)]
  900.     bind $w <Alt-n> "focus $data(ent)"
  901.     bind $w <KeyPress-Escape> "tkButtonInvoke $data(cancelBtn)"
  902.     bind $w <Alt-c> "tkButtonInvoke $data(cancelBtn)"
  903.     bind $w <Alt-o> "tkFDialog_InvokeBtn $w Open"
  904.     bind $w <Alt-s> "tkFDialog_InvokeBtn $w Save"
  905.  
  906.     wm protocol $w WM_DELETE_WINDOW "tkFDialog_CancelCmd $w"
  907.  
  908.     # Build the focus group for all the entries
  909.     #
  910.     tkFocusGroup_Create $w
  911.     tkFocusGroup_BindIn $w  $data(ent) "tkFDialog_EntFocusIn $w"
  912.     tkFocusGroup_BindOut $w $data(ent) "tkFDialog_EntFocusOut $w"
  913. }
  914.  
  915. # tkFDialog_UpdateWhenIdle --
  916. #
  917. #    Creates an idle event handler which updates the dialog in idle
  918. #    time. This is important because loading the directory may take a long
  919. #    time and we don't want to load the same directory for multiple times
  920. #    due to multiple concurrent events.
  921. #
  922. proc tkFDialog_UpdateWhenIdle {w} {
  923.     upvar #0 $w data
  924.  
  925.     if [info exists data(updateId)] {
  926.     return
  927.     } else {
  928.     set data(updateId) [after idle tkFDialog_Update $w]
  929.     }
  930. }
  931.  
  932. # tkFDialog_Update --
  933. #
  934. #    Loads the files and directories into the IconList widget. Also
  935. #    sets up the directory option menu for quick access to parent
  936. #    directories.
  937. #
  938. proc tkFDialog_Update {w} {
  939.     upvar #0 $w data
  940.     global tk_library tkPriv
  941.  
  942.     # This proc may be called within an idle handler. Make sure that the
  943.     # window has not been destroyed before this proc is called
  944.     if {![winfo exists $w] || [string compare [winfo class $w] TkFDialog]} {
  945.     return
  946.     } else {
  947.     catch {unset data(updateId)}
  948.     }
  949.  
  950.     set TRANSPARENT_GIF_COLOR [$w cget -bg]
  951.     if ![info exists tkPriv(folderImage)] {
  952.     set tkPriv(folderImage) [image create photo -data {
  953. R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
  954. QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]
  955.     set tkPriv(fileImage)   [image create photo -data {
  956. R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO
  957. rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]
  958.     }
  959.     set folder $tkPriv(folderImage)
  960.     set file   $tkPriv(fileImage)
  961.  
  962.     set appPWD [pwd]
  963.     if [catch {
  964.     cd $data(selectPath)
  965.     }] {
  966.     # We cannot change directory to $data(selectPath). $data(selectPath)
  967.     # should have been checked before tkFDialog_Update is called, so
  968.     # we normally won't come to here. Anyways, give an error and abort
  969.     # action.
  970.     tk_messageBox -type ok -message \
  971.         "Cannot change to the directory \"$data(selectPath)\".\nPermission denied."\
  972.         -icon warning
  973.     cd $appPWD
  974.     return
  975.     }
  976.  
  977.     # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
  978.     # so the user may still click and cause havoc ...
  979.     #
  980.     set entCursor [$data(ent) cget -cursor]
  981.     set dlgCursor [$w         cget -cursor]
  982.     $data(ent) config -cursor watch
  983.     $w         config -cursor watch
  984.     update idletasks
  985.     
  986.     tkIconList_DeleteAll $data(icons)
  987.  
  988.     # Make the dir list
  989.     #
  990.     foreach f [lsort -dictionary [glob -nocomplain .* *]] {
  991.     if ![string compare $f .] {
  992.         continue
  993.     }
  994.     if ![string compare $f ..] {
  995.         continue
  996.     }
  997.     if [file isdir ./$f] {
  998.         if ![info exists hasDoneDir($f)] {
  999.         tkIconList_Add $data(icons) $folder $f
  1000.         set hasDoneDir($f) 1
  1001.         }
  1002.     }
  1003.     }
  1004.     # Make the file list
  1005.     #
  1006.     if ![string compare $data(filter) *] {
  1007.     set files [lsort -dictionary \
  1008.         [glob -nocomplain .* *]]
  1009.     } else {
  1010.     set files [lsort -dictionary \
  1011.         [eval glob -nocomplain $data(filter)]]
  1012.     }
  1013.  
  1014.     set top 0
  1015.     foreach f $files {
  1016.     if ![file isdir ./$f] {
  1017.         if ![info exists hasDoneFile($f)] {
  1018.         tkIconList_Add $data(icons) $file $f
  1019.         set hasDoneFile($f) 1
  1020.         }
  1021.     }
  1022.     }
  1023.  
  1024.     tkIconList_Arrange $data(icons)
  1025.  
  1026.     # Update the Directory: option menu
  1027.     #
  1028.     set list ""
  1029.     set dir ""
  1030.     foreach subdir [file split $data(selectPath)] {
  1031.     set dir [file join $dir $subdir]
  1032.     lappend list $dir
  1033.     }
  1034.  
  1035.     $data(dirMenu) delete 0 end
  1036.     set var [format %s(selectPath) $w]
  1037.     foreach path $list {
  1038.     $data(dirMenu) add command -label $path -command [list set $var $path]
  1039.     }
  1040.  
  1041.     # Restore the PWD to the application's PWD
  1042.     #
  1043.     cd $appPWD
  1044.  
  1045.     # turn off the busy cursor.
  1046.     #
  1047.     $data(ent) config -cursor $entCursor
  1048.     $w         config -cursor $dlgCursor
  1049. }
  1050.  
  1051. # tkFDialog_SetPathSilently --
  1052. #
  1053. #     Sets data(selectPath) without invoking the trace procedure
  1054. #
  1055. proc tkFDialog_SetPathSilently {w path} {
  1056.     upvar #0 $w data
  1057.  
  1058.     trace vdelete  data(selectPath) w "tkFDialog_SetPath $w"
  1059.     set data(selectPath) $path
  1060.     trace variable data(selectPath) w "tkFDialog_SetPath $w"
  1061. }
  1062.  
  1063.  
  1064. # This proc gets called whenever data(selectPath) is set
  1065. #
  1066. proc tkFDialog_SetPath {w name1 name2 op} {
  1067.     upvar #0 $w data
  1068.  
  1069.     tkFDialog_UpdateWhenIdle $w
  1070. }
  1071.  
  1072. # This proc gets called whenever data(filter) is set
  1073. #
  1074. proc tkFDialog_SetFilter {w type} {
  1075.     upvar #0 $w data
  1076.     upvar \#0 $data(icons) icons
  1077.  
  1078.     set data(filter) [lindex $type 1]
  1079.     $data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1
  1080.  
  1081.     $icons(sbar) set 0.0 0.0
  1082.     
  1083.     tkFDialog_UpdateWhenIdle $w
  1084. }
  1085.  
  1086. # tkFDialogResolveFile --
  1087. #
  1088. #    Interpret the user's text input in a file selection dialog.
  1089. #    Performs:
  1090. #
  1091. #    (1) ~ substitution
  1092. #    (2) resolve all instances of . and ..
  1093. #    (3) check for non-existent files/directories
  1094. #    (4) check for chdir permissions
  1095. #
  1096. # Arguments:
  1097. #    context:  the current directory you are in
  1098. #    text:      the text entered by the user
  1099. #    defaultext: the default extension to add to files with no extension
  1100. #
  1101. # Return vaue:
  1102. #    [list $flag $directory $file]
  1103. #
  1104. #     flag = OK    : valid input
  1105. #          = PATTERN    : valid directory/pattern
  1106. #          = PATH    : the directory does not exist
  1107. #          = FILE    : the directory exists by the file doesn't
  1108. #              exist
  1109. #          = CHDIR    : Cannot change to the directory
  1110. #          = ERROR    : Invalid entry
  1111. #
  1112. #     directory      : valid only if flag = OK or PATTERN or FILE
  1113. #     file           : valid only if flag = OK or PATTERN
  1114. #
  1115. #    directory may not be the same as context, because text may contain
  1116. #    a subdirectory name
  1117. #
  1118. proc tkFDialogResolveFile {context text defaultext} {
  1119.  
  1120.     set appPWD [pwd]
  1121.  
  1122.     set path [tkFDialog_JoinFile $context $text]
  1123.  
  1124.     if {[file ext $path] == ""} {
  1125.     set path "$path$defaultext"
  1126.     }
  1127.  
  1128.     if [catch {file exists $path}] {
  1129.     return [list ERROR $path ""]
  1130.     }
  1131.  
  1132.     if [catch {if [file exists $path] {}}] {
  1133.     # This "if" block can be safely removed if the following code returns
  1134.     # an error. It currently (7/22/97) doesn't
  1135.     #
  1136.     #    file exists ~nonsuchuser
  1137.     #
  1138.     return [list ERROR $path ""]
  1139.     }
  1140.  
  1141.     if [file exists $path] {
  1142.     if [file isdirectory $path] {
  1143.         if [catch {
  1144.         cd $path
  1145.         }] {
  1146.         return [list CHDIR $path ""]
  1147.         }
  1148.         set directory [pwd]
  1149.         set file ""
  1150.         set flag OK
  1151.         cd $appPWD
  1152.     } else {
  1153.         if [catch {
  1154.         cd [file dirname $path]
  1155.         }] {
  1156.         return [list CHDIR [file dirname $path] ""]
  1157.         }
  1158.         set directory [pwd]
  1159.         set file [file tail $path]
  1160.         set flag OK
  1161.         cd $appPWD
  1162.     }
  1163.     } else {
  1164.     set dirname [file dirname $path]
  1165.     if [file exists $dirname] {
  1166.         if [catch {
  1167.         cd $dirname
  1168.         }] {
  1169.         return [list CHDIR $dirname ""]
  1170.         }
  1171.         set directory [pwd]
  1172.         set file [file tail $path]
  1173.         if [regexp {[*]|[?]} $file] {
  1174.         set flag PATTERN
  1175.         } else {
  1176.         set flag FILE
  1177.         }
  1178.         cd $appPWD
  1179.     } else {
  1180.         set directory $dirname
  1181.         set file [file tail $path]
  1182.         set flag PATH
  1183.     }
  1184.     }
  1185.  
  1186.     return [list $flag $directory $file]
  1187. }
  1188.  
  1189.  
  1190. # Gets called when the entry box gets keyboard focus. We clear the selection
  1191. # from the icon list . This way the user can be certain that the input in the 
  1192. # entry box is the selection.
  1193. #
  1194. proc tkFDialog_EntFocusIn {w} {
  1195.     upvar #0 $w data
  1196.  
  1197.     if [string compare [$data(ent) get] ""] {
  1198.     $data(ent) selection from 0
  1199.     $data(ent) selection to   end
  1200.     $data(ent) icursor end
  1201.     } else {
  1202.     $data(ent) selection clear
  1203.     }
  1204.  
  1205.     tkIconList_Unselect $data(icons)
  1206.  
  1207.     if ![string compare $data(type) open] {
  1208.     $data(okBtn) config -text "Open"
  1209.     } else {
  1210.     $data(okBtn) config -text "Save"
  1211.     }
  1212. }
  1213.  
  1214. proc tkFDialog_EntFocusOut {w} {
  1215.     upvar #0 $w data
  1216.  
  1217.     $data(ent) selection clear
  1218. }
  1219.  
  1220.  
  1221. # Gets called when user presses Return in the "File name" entry.
  1222. #
  1223. proc tkFDialog_ActivateEnt {w} {
  1224.     upvar #0 $w data
  1225.  
  1226.     set text [string trim [$data(ent) get]]
  1227.     set list [tkFDialogResolveFile $data(selectPath) $text \
  1228.           $data(-defaultextension)]
  1229.     set flag [lindex $list 0]
  1230.     set path [lindex $list 1]
  1231.     set file [lindex $list 2]
  1232.  
  1233.     case $flag {
  1234.     OK {
  1235.         if ![string compare $file ""] {
  1236.         # user has entered an existing (sub)directory
  1237.         set data(selectPath) $path
  1238.         $data(ent) delete 0 end
  1239.         } else {
  1240.         tkFDialog_SetPathSilently $w $path
  1241.         set data(selectFile) $file
  1242.         tkFDialog_Done $w
  1243.         }
  1244.     }
  1245.     PATTERN {
  1246.         set data(selectPath) $path
  1247.         set data(filter) $file
  1248.     }
  1249.     FILE {
  1250.         if ![string compare $data(type) open] {
  1251.         tk_messageBox -icon warning -type ok \
  1252.             -message "File \"[file join $path $file]\" does not exist."
  1253.         $data(ent) select from 0
  1254.         $data(ent) select to   end
  1255.         $data(ent) icursor end
  1256.         } else {
  1257.         tkFDialog_SetPathSilently $w $path
  1258.         set data(selectFile) $file
  1259.         tkFDialog_Done $w
  1260.         }
  1261.     }
  1262.     PATH {
  1263.         tk_messageBox -icon warning -type ok \
  1264.         -message "Directory \"$path\" does not exist."
  1265.         $data(ent) select from 0
  1266.         $data(ent) select to   end
  1267.         $data(ent) icursor end
  1268.     }
  1269.     CHDIR {
  1270.         tk_messageBox -type ok -message \
  1271.            "Cannot change to the directory \"$path\".\nPermission denied."\
  1272.         -icon warning
  1273.         $data(ent) select from 0
  1274.         $data(ent) select to   end
  1275.         $data(ent) icursor end
  1276.     }
  1277.     ERROR {
  1278.         tk_messageBox -type ok -message \
  1279.            "Invalid file name \"$path\"."\
  1280.         -icon warning
  1281.         $data(ent) select from 0
  1282.         $data(ent) select to   end
  1283.         $data(ent) icursor end
  1284.     }
  1285.     }
  1286. }
  1287.  
  1288. # Gets called when user presses the Alt-s or Alt-o keys.
  1289. #
  1290. proc tkFDialog_InvokeBtn {w key} {
  1291.     upvar #0 $w data
  1292.  
  1293.     if ![string compare [$data(okBtn) cget -text] $key] {
  1294.     tkButtonInvoke $data(okBtn)
  1295.     }
  1296. }
  1297.  
  1298. # Gets called when user presses the "parent directory" button
  1299. #
  1300. proc tkFDialog_UpDirCmd {w} {
  1301.     upvar #0 $w data
  1302.  
  1303.     if [string compare $data(selectPath) "/"] {
  1304.     set data(selectPath) [file dirname $data(selectPath)]
  1305.     }
  1306. }
  1307.  
  1308. # Join a file name to a path name. The "file join" command will break
  1309. # if the filename begins with ~
  1310. #
  1311. proc tkFDialog_JoinFile {path file} {
  1312.     if {[string match {~*} $file] && [file exists $path/$file]} {
  1313.     return [file join $path ./$file]
  1314.     } else {
  1315.     return [file join $path $file]
  1316.     }
  1317. }
  1318.  
  1319.  
  1320.  
  1321. # Gets called when user presses the "OK" button
  1322. #
  1323. proc tkFDialog_OkCmd {w} {
  1324.     upvar #0 $w data
  1325.  
  1326.     set text [tkIconList_Get $data(icons)]
  1327.     if [string compare $text ""] {
  1328.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1329.     if [file isdirectory $file] {
  1330.         tkFDialog_ListInvoke $w $text
  1331.         return
  1332.     }
  1333.     }
  1334.  
  1335.     tkFDialog_ActivateEnt $w
  1336. }
  1337.  
  1338. # Gets called when user presses the "Cancel" button
  1339. #
  1340. proc tkFDialog_CancelCmd {w} {
  1341.     upvar #0 $w data
  1342.     global tkPriv
  1343.  
  1344.     set tkPriv(selectFilePath) ""
  1345. }
  1346.  
  1347. # Gets called when user browses the IconList widget (dragging mouse, arrow
  1348. # keys, etc)
  1349. #
  1350. proc tkFDialog_ListBrowse {w text} {
  1351.     upvar #0 $w data
  1352.  
  1353.     if {$text == ""} {
  1354.     return
  1355.     }
  1356.  
  1357.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1358.     if ![file isdirectory $file] {
  1359.     $data(ent) delete 0 end
  1360.     $data(ent) insert 0 $text
  1361.  
  1362.     if ![string compare $data(type) open] {
  1363.         $data(okBtn) config -text "Open"
  1364.     } else {
  1365.         $data(okBtn) config -text "Save"
  1366.     }
  1367.     } else {
  1368.     $data(okBtn) config -text "Open"
  1369.     }
  1370. }
  1371.  
  1372. # Gets called when user invokes the IconList widget (double-click, 
  1373. # Return key, etc)
  1374. #
  1375. proc tkFDialog_ListInvoke {w text} {
  1376.     upvar #0 $w data
  1377.  
  1378.     if {$text == ""} {
  1379.     return
  1380.     }
  1381.  
  1382.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1383.  
  1384.     if [file isdirectory $file] {
  1385.     set appPWD [pwd]
  1386.     if [catch {cd $file}] {
  1387.         tk_messageBox -type ok -message \
  1388.            "Cannot change to the directory \"$file\".\nPermission denied."\
  1389.         -icon warning
  1390.     } else {
  1391.         cd $appPWD
  1392.         set data(selectPath) $file
  1393.     }
  1394.     } else {
  1395.     set data(selectFile) $file
  1396.     tkFDialog_Done $w
  1397.     }
  1398. }
  1399.  
  1400. # tkFDialog_Done --
  1401. #
  1402. #    Gets called when user has input a valid filename.  Pops up a
  1403. #    dialog box to confirm selection when necessary. Sets the
  1404. #    tkPriv(selectFilePath) variable, which will break the "tkwait"
  1405. #    loop in tkFDialog and return the selected filename to the
  1406. #    script that calls tk_getOpenFile or tk_getSaveFile
  1407. #
  1408. proc tkFDialog_Done {w {selectFilePath ""}} {
  1409.     upvar #0 $w data
  1410.     global tkPriv
  1411.  
  1412.     if ![string compare $selectFilePath ""] {
  1413.     set selectFilePath [tkFDialog_JoinFile $data(selectPath) \
  1414.         $data(selectFile)]
  1415.     set tkPriv(selectFile)     $data(selectFile)
  1416.     set tkPriv(selectPath)     $data(selectPath)
  1417.  
  1418.     if {[file exists $selectFilePath] && 
  1419.         ![string compare $data(type) save]} {
  1420.  
  1421.         set reply [tk_messageBox -icon warning -type yesno \
  1422.             -message "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?"]
  1423.         if ![string compare $reply "no"] {
  1424.         return
  1425.         }
  1426.     }
  1427.     }
  1428.     set tkPriv(selectFilePath) $selectFilePath
  1429. }
  1430.  
  1431.